home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / prelude / PreludeIOCompat.hs < prev    next >
Encoding:
Text File  |  1994-09-27  |  5.0 KB  |  141 lines  |  [TEXT/YHS2]
  1.  
  2. {- This is for compatibility with the old IO system.  No module for stream
  3.    IO compatibility is provided. -}
  4.  
  5. module PreludeContinuationIO(Prelude..,PreludeContinuationIO..) where
  6.  
  7. {-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
  8.  
  9. import Prelude renaming (readFile to monadicReadFile,
  10.                          writeFile to monadicWriteFile,
  11.                          appendFile to monadicAppendFile,
  12.                          deleteFile to monadicDeleteFile,
  13.                          statusFile to monadicStatusFile,
  14.                          statusChan to monadicStatusChan,
  15.                          appendChan to monadicAppendChan,
  16.                          readChan to monadicReadChan,
  17.              getArgs to monadicGetArgs,
  18.              getProgName to monadicGetProgName,
  19.                          getEnv to monadicGetEnv,
  20.                          setEnv to monadicSetEnv,
  21.              stdin to monadicStdin,
  22.              stdout to monadicStdout,
  23.              stderr to monadicStderr)
  24.  
  25.  
  26. -- Continuation-based I/O:
  27.  
  28. type Dialogue    =  IO ()
  29. type SuccCont    =                Dialogue
  30. type StrCont     =  String     -> Dialogue
  31. type StrListCont =  [String]   -> Dialogue
  32. type BinCont     =  Bin        -> Dialogue
  33. type FailCont    =  IOError    -> Dialogue
  34.  
  35. stdin = "stdin"
  36. stdout = "stdout"
  37. stderr = "stderr"
  38. stdecho = "stdecho"
  39.  
  40. {- The IOError type is slightly different in 1.3 but there is no
  41.    real need to redefine it since 1.2 programs should have no problem
  42.    using the 1.3 definition. -}
  43.  
  44. done          ::                                                Dialogue
  45. readFile      :: String ->           FailCont -> StrCont     -> Dialogue
  46. writeFile     :: String -> String -> FailCont -> SuccCont    -> Dialogue
  47. appendFile    :: String -> String -> FailCont -> SuccCont    -> Dialogue
  48. {- Binary files are no longer a part of 1.3; they will be omitted for now -}
  49. -- readBinFile   :: String ->           FailCont -> BinCont     -> Dialogue
  50. -- writeBinFile  :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
  51. -- appendBinFile :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
  52. deleteFile    :: String ->           FailCont -> SuccCont    -> Dialogue
  53. statusFile    :: String ->           FailCont -> StrCont     -> Dialogue
  54. readChan      :: String ->           FailCont -> StrCont     -> Dialogue
  55. appendChan    :: String -> String -> FailCont -> SuccCont    -> Dialogue
  56. -- readBinChan   :: String ->           FailCont -> BinCont     -> Dialogue
  57. -- appendBinChan :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
  58. statusChan    :: String ->           FailCont -> StrCont     -> Dialogue
  59. echo          :: Bool ->             FailCont -> SuccCont    -> Dialogue
  60. getArgs          ::             FailCont -> StrListCont -> Dialogue
  61. getProgName   ::             FailCont -> StrCont     -> Dialogue
  62. getEnv          :: String ->         FailCont -> StrCont     -> Dialogue
  63. setEnv          :: String -> String -> FailCont -> SuccCont    -> Dialogue
  64.  
  65. done = return ()
  66.  
  67. -- This performs an IO operation and calls either a success or failure
  68. -- continuation.  The result of the IO operation is passed to the success cont.
  69.  
  70. withErrorCont :: IO a -> FailCont -> (a -> IO ()) -> IO ()
  71. withErrorCont op fail succ =
  72.   try (op >>= \r -> return (Right r)) (\err -> return (Left err))
  73.     >>= \res -> either fail succ res
  74.  
  75. -- When the success continuation does not use the result of the
  76. -- IO operation use this.
  77.  
  78. withErrorCont_ :: IO a -> FailCont -> IO () -> IO ()
  79. withErrorCont_ op fail succ = withErrorCont op fail (\_ -> succ)
  80.  
  81. readFile name =
  82.    withErrorCont (monadicReadFile name) 
  83.  
  84. writeFile name contents =
  85.    withErrorCont_ (monadicWriteFile name contents)
  86.  
  87. appendFile name contents =
  88.    withErrorCont_ (monadicAppendFile name contents)
  89.  
  90. deleteFile name =
  91.    withErrorCont_ (monadicDeleteFile name)
  92.  
  93. statusFile name =
  94.    withErrorCont (monadicStatusFile name)
  95.  
  96. readChan name fail succ =
  97.  if name == "stdin" then
  98.     getContents monadicStdin >>= succ -- Assumes this cannot fail
  99.  else
  100.     fail (OtherError ("Bad input channel : " ++ name))
  101.  
  102. appendChan name contents fail succ =
  103.  if name == "stdout" || name == "stderr" then
  104.     hPutStr monadicStdout contents >> succ  -- assumes hPutStr cannot fail
  105.  else
  106.     fail (OtherError ("Bad output channel : " ++ name))
  107.  
  108. statusChan name =
  109.  withErrorCont (monadicStatusChan name)
  110.  
  111. echo bool fail succ =
  112.   if bool then
  113.      succ
  114.   else
  115.      fail (OtherError "Echo cannot be turned off")
  116.  
  117. getArgs = withErrorCont monadicGetArgs
  118.  
  119. getProgName = withErrorCont monadicGetProgName
  120.  
  121. getEnv name = withErrorCont (monadicGetEnv name)
  122.  
  123. setEnv name val = withErrorCont_ (monadicSetEnv name val)
  124.  
  125. abort        :: FailCont
  126. abort err    =  done
  127.  
  128. exit        :: FailCont
  129. exit err    = appendChan stderr (show err ++ "\n") abort done
  130.  
  131. print        :: (Text a) => a -> Dialogue
  132. print x        =  appendChan stdout (show x) exit done
  133. prints          :: (Text a) => a -> String -> Dialogue
  134. prints x s    =  appendChan stdout (shows x s) exit done
  135.  
  136. -- Already in monadic IO system
  137. -- interact    :: (String -> String) -> Dialogue
  138. -- interact f    =  readChan stdin exit
  139. --                (\x -> appendChan stdout (f x) exit done)
  140.  
  141.